(*$S+*)
PROGRAM Format;

CONST  AlfaLeng = 10;
       MinChar = 0;
       MaxChar = 127;   (* minimum/max char values *)
       LastPascSymbol = 29;
       (* if needed, change the values on the following line TOGETHER *)
       BufferSize = 160; BuffSzP1 = 161; BuffSzM1 = 159; BuffSzDiv10 = 16;
       
       MaxReadRightCol = 999;
       MaxWriteRightCon = 72;
       
TYPE  Alfa = PACKED ARRAY [1..AlfaLeng] OF char;
      CharSet = SET OF char;
      StatmntTypes = (ForWithWhileStatement, RepeatStatement,
                      IfStatement, CaseStatement, CompoundStatement,
                      OtherStatement);
      Symbols = (ProgSymbol, Comment, BeginSymbol, EndSymbol,
                 SemiColon, ConstSymbol, TypeSymbol,
                 RecordSymbol, ColonSymbol, EqualSymbol,
                 PeriodSymbol, Range, CaseSymbol, OtherSymbol,
                 IfSymbol, ThenSymbol, ElseSymbol, DoSymbol,
                 OfSymbol, ForSymbol, WithSymbol, WhileSymbol,
                 RepeatSymbol, UntilSymbol, Identifier,
                 VarSymbol, ProcSymbol, FuncSymbol, LeftBracket,
                 RightBracket, CommaSymbol, LabelSymbol,
                 LeftParenth, RightParenth, AlphaOperator);
      Width = 0..BufferSize;
      Margins = -100..BufferSize;
      SymbolSet = SET OF Symbols;
      OptionSize = -99..99;
      CommentText = ARRAY [1..BuffSzDiv10] OF Alfa;
      SymbolString = ARRAY [Width] OF char; (*the only UNPACKED char array*)
      
VAR  ChIsEOL, NextChIsEOL: Boolean;
     I, J: Integer (*loop counters *);
     Character: char;
     ReadColumn, ReadRightCol: 0..1000;
     Length, Oldest: Width;
     
     OutputCol, WriteColumn, LeftMargin,
     ActualLeftMargin, ReadLeftCol, WriteLeftCol, WriteRightCol : Margins;
     
     DisplayIsOn, ProcNamesWanted, EndCommentsWanted,
     PackerIsOff, SavedBunch, BunchWanted, NoFormatting: boolean;
     
     LineNumber, Increment: integer;
     
     IndentIndex, LongLineIndent, SymbolGap,
     DeclarAlignment, StatmtSeparation, ProcSeparation: OptionSize;
     
     SymbolIsNumber, LastProgPartWasBody: Boolean;
     LastSymbol, SymbolName: Symbols;
     CharCount: integer;
     AlphaSymbols, EndLabel, EndConst, EndType, EndVar: SymbolSet;
     Symbol: SymbolString;
     Digits, Letters, LettersAndDigits: CharSet;
     Main: CommentText;
     MainNmLength: Width;
     Blanks, Zeroes: Alfa;
     UnWritten: ARRAY [Width] OF RECORD
                                   Ch: char;
                                   ChIsEndLine: boolean;
                                   IndentAfterEOL: margins
                                 END;
     PascalSymbol: ARRAY [1..LastPascSymbol] OF Alfa;
     PascSymbolName: ARRAY [1..LastPascSymbol] OF Symbols;
     NameOf: ARRAY [Char] OF Symbols;
     StatementTypeOf: ARRAY [Symbols] OF StatmntTypes;
     Infile, Outfile: text;
     
     
PROCEDURE Const1Init;

BEGIN
  Main [1] := 'MAIN      ';  MainNmLength := 4;
  Blanks := '          ';  Zeroes := '0000000000';
  FOR I := 0 TO BuffSzM1 DO
    WITH UnWritten [I] DO
      BEGIN ch := 'A'; ChIsEndLine := false; IndentAfterEOL := 0
      END;
  FOR Character := Chr (MinChar) TO chr (MaxChar) DO
    NameOf [Character] := OtherSymbol;
  Character := ' '; NameOf ['('] := LeftParenth;
  NameOf [')'] := RightParenth;  NameOf ['='] := EqualSymbol;
  NameOf [','] := CommaSymbol;   NameOf ['.'] := PeriodSymbol;
  NameOf ['['] := LeftBracket;   NameOf [']'] := RightBracket;
  NameOf [':'] := ColonSymbol;   NameOf ['<'] := EqualSymbol;
  NameOf ['>'] := EqualSymbol;   NameOf [';'] := Semicolon;
  PascalSymbol [ 1] := 'PROGRAM   ';  PascalSymbol [ 2] := 'BEGIN     ';
  PascalSymbol [ 3] := 'END       ';  PascalSymbol [ 4] := 'CONST     ';
  PascalSymbol [ 5] := 'TYPE      ';  PascalSymbol [ 6] := 'VAR       ';
  PascalSymbol [ 7] := 'RECORD    ';  PascalSymbol [ 8] := 'CASE      ';
  PascalSymbol [ 9] := 'IF        ';  PascalSymbol [10] := 'THEN      ';
  PascalSymbol [11] := 'ELSE      ';  PascalSymbol [12] := 'DO        ';
  PascalSymbol [13] := 'OF        ';  PascalSymbol [14] := 'FOR       ';
  PascalSymbol [15] := 'WHILE     ';  PascalSymbol [16] := 'WITH      ';
  PascalSymbol [17] := 'REPEAT    ';  PascalSymbol [18] := 'UNTIL     ';
  PascalSymbol [19] := 'PROCEDURE ';  PascalSymbol [20] := 'FUNCTION  ';
  PascalSymbol [21] := 'LABEL     ';  PascalSymbol [22] := 'IN        ';
  PascalSymbol [23] := 'MOD       ';  PascalSymbol [24] := 'DIV       ';
  PascalSymbol [25] := 'AND       ';  PascalSymbol [26] := 'OR        ';
  PascalSymbol [27] := 'NOT       ';  PascalSymbol [28] := 'ARRAY     ';
  PascalSymbol [29] := 'NOSYMBOL  ';   
END;


PROCEDURE ConstantsInitialization;
BEGIN
  Const1Init;
  PascSymbolName [ 1] :=  ProgSymbol;
  PascSymbolName [ 2] := BeginSymbol;  PascSymbolName [ 3] :=    EndSymbol;
  PascSymbolName [ 4] := ConstSymbol;  PascSymbolName [ 5] :=   TypeSymbol;
  PascSymbolName [ 6] :=   VarSymbol;  PascSymbolName [ 7] := RecordSymbol;
  PascSymbolName [ 8] :=  CaseSymbol;  PascSymbolName [ 9] :=     IfSymbol;
  PascSymbolName [10] :=  ThenSymbol;  PascSymbolName [11] :=   ElseSymbol;
  PascSymbolName [12] :=    DoSymbol;  PascSymbolName [13] :=     OfSymbol;
  PascSymbolName [14] :=   ForSymbol;  PascSymbolName [15] :=  WhileSymbol;
  PascSymbolName [16] :=  WithSymbol;  PascSymbolName [17] := RepeatSymbol;
  PascSymbolName [18] := UntilSymbol;  PascSymbolName [19] :=   ProcSymbol;
  PascSymbolName [20] :=  FuncSymbol;  PascSymbolName [21] :=  LabelSymbol;
  PascSymbolName [29] :=  Identifier;
  FOR I := 22 TO 28 DO PascSymbolName [I] := AlphaOperator;
  FOR SymbolName := ProgSymbol TO AlphaOperator DO
    StatementTypeOf [SymbolName] := OtherStatement;
  StatementTypeOf [ BeginSymbol] :=     CompoundStatement;
  StatementTypeOf [  CaseSymbol] :=         CaseStatement;
  StatementTypeOf [    IfSymbol] :=           IfStatement;
  StatementTypeOf [   ForSymbol] := ForWithWhileStatement;
  StatementTypeOf [ WhileSymbol] := ForWithWhileStatement;
  StatementTypeOf [  WithSymbol] := ForWithWhileStatement;
  StatementTypeOf [RepeatSymbol] :=       RepeatStatement;
END (*ConstantsInitialization*);


PROCEDURE WriteA (Character: char);
VAR  I: Width;
     TestNo: Integer;
BEGIN
  CharCount := CharCount + 1;  Oldest := CharCount MOD BufferSize;
  WITH UnWritten [Oldest] DO
    BEGIN
      IF CharCount > BuffSzP1
        THEN BEGIN
          IF ChIsEndLine
            THEN BEGIN
              IF IndentAfterEOL < 0
                THEN BEGIN
                  Write (Outfile, Blanks: - IndentAfterEOL);
                  OutputCol := OutputCol - IndentAfterEOL;
                END
                ELSE BEGIN
                  IF Increment < 0
                    THEN BEGIN
                      I := WriteRightCol - OutputCol + 1;
                      IF I > 0 THEN Write (Outfile, Blanks: I);
                      TestNo := LineNumber;  I := 0;
                      REPEAT TestNo := TestNo DIV 10;  I := I + 1;
                      UNTIL TestNo = 0;
                      Write (Outfile, Zeroes: (6 - I), LineNumber: I);
                      LineNumber := LineNumber + Increment;
                      IF LineNumber > 9999
                      THEN LineNumber := LineNumber - 10000;
                      Writeln (Outfile);
                    END
                    ELSE BEGIN
                      Writeln (Outfile);
                      IF Increment > 0
                        THEN BEGIN
                          Write (Outfile, LineNumber: 4,' ');
                          LineNumber := LineNumber + Increment;
                        END
                    END;
                  IF IndentAfterEOL > 0
                  THEN Write (Outfile, Blanks: IndentAfterEOL);
                  OutputCol := IndentAfterEOL + 1;
                END;
              ChIsEndLine := false;
            END (*IF ChIsEndLine*)
            ELSE BEGIN Write (Outfile, ch);  OutputCol := OutputCol + 1; END;
        END (*IF CharCount > *);
      Ch := Character;  WriteColumn := WriteColumn + 1;
    END (*with*)
END (*WriteA*);


PROCEDURE FlushUnwrittenBuffer;

BEGIN
  WriteA (' ');
  WITH UnWritten [Oldest] DO
    BEGIN  ChIsEndLine := true;  IndentAfterEOL := 0;  END;
  WriteColumn := 0;  FOR I := 0 TO BuffSzM1 DO WriteA (' ');
END;


PROCEDURE StartNewLineAndIndent;

BEGIN
  IF PackerIsOff AND DisplayIsOn
    THEN BEGIN
      WriteA (' '); LastSymbol := PeriodSymbol;
      WITH UnWritten [Oldest] DO
        BEGIN
          ChIsEndLine := true;
          IndentAfterEOL := WriteLeftCol + LeftMargin - 1;
        END;
      WriteColumn := WriteLeftCol + LeftMargin;
    END
END;


PROCEDURE ReadACharacter;

BEGIN
  IF ReadColumn > ReadRightCol
    THEN BEGIN
      IF ReadRightCol < MaxReadRightCol
        THEN BEGIN NextChIsEOL := true;  Readln (Infile)  END
        ELSE ReadColumn := 2
    END
    ELSE IF ReadColumn = 1 THEN
      WHILE ReadColumn < ReadLeftCol DO
        BEGIN
          IF EOLN (Infile) 
            THEN ReadColumn := 1
            ELSE BEGIN ReadColumn := ReadColumn + 1;  Get (Infile) END
        END;
  IF NextChIsEOL
    THEN BEGIN
      Character := ' ';  NextChIsEOL := false; ChIsEOL := true;
      ReadColumn := 1;
      IF NoFormatting
        THEN BEGIN
          WriteA (' ');
          WITH UnWritten [Oldest] DO
            BEGIN
              ChIsEndLine := true;
              IndentAfterEOL := WriteLeftCol - 1;
            END;
          WriteColumn := WriteLeftCol - 1;
        END;
    END
    ELSE IF NOT eof (Infile)
      THEN BEGIN
        Character := Infile^;  ReadColumn := ReadColumn + 1;
        NextChIsEOL := EOLN (Infile);  Get (Infi˙e);  ChIsEOL := false;
        IF NoFormatting THEN WriteA (Character)
      END
      ELSE BEGIN FlushUnwrittenBuffer; EXIT (Program) END
END (*ReadACharacter*);
                                                                                   

PROCEDURE WriteSymbol;

VAR  I: Width;
     NumberBlanksToWrite: OptionSize;

BEGIN
  IF DisplayIsOn
    THEN BEGIN
      NumberBlanksToWrite := SymbolGap;
      IF (LastSymbol IN [LeftParenth, LeftBracket, PeriodSymbol]) OR
          (SymbolName IN [Semicolon, RightParenth, RightBracket,
          CommaSymbol, PeriodSymbol, ColonSymbol]) OR (SymbolName IN
          [LeftBracket, LeftParenth]) AND (LastSymbol = Identifier)
        THEN NumberBlanksToWrite := 0
        ELSE IF (SymbolName IN AlphaSymbols) AND (LastSymbol IN
                AlphaSymbols)
          THEN IF WriteColumn <= WriteRightCol
            THEN BEGIN
              WriteA (' ');  NumberBlanksToWrite := SymbolGap - 1;
            END;
      IF WriteColumn + Length + NumberBlanksToWrite - 1 >
          WriteRightCol
        THEN BEGIN
          WriteA (' ');
          WITH UnWritten [Oldest] DO
            BEGIN
              ChIsEndLine := true;
              IF PackerIsOff
                THEN BEGIN
                  IF WriteLeftCol + LeftMargin + LongLineIndent +
                      Length - 1 > WriteRightCol
                    THEN Length := 10;
                  IndentAfterEOL := WriteLeftCol - 1 + LeftMargin +
                    LongLineIndent;
                  WriteColumn := WriteLeftCol + LeftMargin +
                    LongLineIndent
                END
                ELSE BEGIN
                  IF Length > WriteRightCol - WriteLeftCol + 1
                    THEN Length := WriteRightCol - WriteLeftCol + 1;
                  IndentAfterEOL := WriteLeftCol - 1;
                  WriteColumn := WriteLeftCol
                END;
            END (*with*);
        END (*then*)
        ELSE FOR I := 1 TO NumberBlanksToWrite DO WriteA (' ');
      FOR I := 1 TO Length DO WriteA (Symbol [I]);
    END (*IF DisplayIsOn*);
  LastSymbol := SymbolName
END (*WriteSymbol*);


PROCEDURE CopyACharacter;

BEGIN
  IF DisplayIsOn
    THEN BEGIN
      IF WriteColumn > WriteRightCol
        THEN BEGIN
          WHILE (Character = ' ') AND NOT ChIsEOL DO
            ReadACharacter;
          IF NOT ChIsEOL THEN StartNewLineAndIndent
        END;
      IF ChIsEOL
        THEN BEGIN
          LeftMargin := 0;  StartNewLineAndIndent;
          LeftMargin := ActualLeftMargin
        END
        ELSE WriteA (Character)
    END;
  ReadACharacter
END (*CopyACharacter*);




PROCEDURE DoFormatterDirectives;

CONST  Invalid = -1;
TYPE  ParamCount = 1..2;
      Params = ARRAY [ParamCount] OF integer;
VAR  Specification: Params;
     FormatOption: char;
     PrevDisplay, PrevNoFormatting: boolean;
     EndDirectiv: CharSet;


PROCEDURE ReadIn (N: ParamCount; VAR Specification: Params);

VAR I: ParamCount;

BEGIN
  FOR I := 1 TO N DO
    BEGIN
      WHILE NOT (Character IN (Digits + EndDirectv)) DO CopyACharacter;
      Specification [I] := 0;
      IF NOT (Character IN EndDirectiv)
        THEN 
          REPEAT
            Specification [I] := 10 * Specification [I] + ORD (Character)
              - ORD ('0');
            CopyACharacter
          UNTIL NOT (Character IN Digits)
        ELSE Specification [I] := Invalid;
    END
END (*ReadIn*);


BEGIN (*DoFormatterDirectives*);
  EndDirective := ['*', ']'];
  REPEAT IF Character IN ['A'..'G', 'I', 'L', 'N', 'P', 'R', 'S', 'W']
    THEN BEGIN
      FormatOption := Character;
      CASE FormatOption OF
        'A', 'E', 'I', 'G', 'P', 'L', 'S':
          BEGIN
            ReadIn (1, Specification);
            IF (Specification [1] < WriteRightCol - WriteLeftCol - 9)
                OR (FormatOption = 'P')
              THEN CASE FormatOption OF
                'A':  DeclarAlignment := Specification [1];
                'E':  IF Specification [1] < 4
                        THEN BEGIN
                          ProcNamesWanted := Specification [1] > 1;
                          EndCommentsWanted := Odd(Specification [1])
                        END;
                'G':  SymbolGap := Specification [1];
                'I':  IndentIndex := Specification [1];
                'L':  LongLineIndent := Specification [1];
                'P':  ProcSeparation := Specification [1];
                'S':  StatmtSeparation := Specification [1]
              END (*case*)
          END (*1st 7 letters*);
        'W', 'R', 'N':
          BEGIN
            ReadIn (2, Specification);
            IF Specification [2] <> Invalid
              THEN CASE FormatOption OF
                'W':  IF (Specification [1] > 0) AND (Specification [2] <
                          BufferSize - 2) AND (Specification [2] -
                          Specification [1] > 8)
                        THEN BEGIN
                          WriteLeftCol := Specification [1];
                          WriteRightCol := Specification [2]
                        END;
                'R':  IF (Specification [1] > 0) AND (Specification [2] -
                          Specification [1] > 8)
                        THEN BEGIN
                          ReadLeftCol := Specification [1];
                          ReadRightCol := Specification [2]
                        END;
                'N':  BEGIN
                        LineNumber := Specification [1];
                        Increment := Specification [2];
                        WHILE NOT (Character IN (['<'] + EndDirectv))
                            AND (Character <> '>') DO
                          CopyACharacter;
                        IF Character = '>' THEN Increment := - Increment
                      END
              END (*case*);
          END (*Next 2 letters*);
        'B', 'C', 'D', 'F':
          BEGIN
            REPEAT CopyACharacter
            UNTIL Character IN (['+', '-'] + EndDirectv);
            IF Character IN ['+', '-']
              THEN CASE FormatOption OF
                'B':  IF DisplayIsOn THEN BunchWanted := Character = '+';
                'C':  PackerIsOff := Character = '-';
                'D':  BEGIN
                        PrevDisplay := DisplayIsOn;
                        DisplayIsOn := Character = '+';
                        IF PrevDisplay AND NOT DisplayIsOn
                          THEN BEGIN
                            WriteA ('*'); WriteA (')');
                            SavedBunch := BunchWanted;
                            BunchWanted := false
                          END
                          ELSE IF NOT PrevDisplay AND DisplayIsOn
                            THEN BEGIN
                              StartNewLineAndIndent;  WriteA ('(');
                              WriteA ('*');  BunchWanted := SavedBunch
                            END
                      END;
                'F':  BEGIN
                        PrevNoFormatting := NoFormatting;
                        NoFormatting := Character = '-';
                        DisplayIsOn := NOT NoFormatting;
                        IF PrevNoFormatting AND NOT NoFormatting
                          THEN ReadACharacter;
                        IF NOT PrevNoFormatting AND NoFormatting
                          THEN WriteA ('-');
                      END
              END (*case*)
          END (*boolean parameters*)
      END (*main case statement*);
    END (*then*)
    ELSE IF NOT (Character IN EndDirectv) THEN CopyACharacter
  UNTIL Character IN EndDirectv;
  IF Character = ']' THEN CopyACharacter
END (*DoFormatterDirectives*);




PROCEDURE ReadSymbol;

CONST  ReadNextCh = true;
       DontReadNextCh = false;
VAR  TestSymbol: Alfa;
     CharNumber, I: Width;



PROCEDURE SkipComment;
BEGIN
  REPEAT WHILE Character <> '*' DO ReadACharacter; ReadACharacter
  UNTIL Character = ')';
  ReadACharacter; LastSymbol := comment; ReadSymbol
END;



PROCEDURE DoComment;

VAR  I: OptionSize;

PROCEDURE CompilerDirectives;
BEGIN REPEAT CopyACharacter UNTIL Character IN ['[', '*'] END;

BEGIN (*DoComment*)
  BEGIN
    IF LastSymbol IN [Comment, Semicolon]
      THEN BEGIN
        LeftMargin := 0;  StartNewLineAndIndent;
        LeftMargin := ActualLeftMargin
      END;
    WriteSymbol;  If Character = '$' THEN CompilerDirectives;
    IF Character = '[' THEN DoFormatterDirectives;
    REPEAT WHILE Character <> '*' DO CopyACharacter;  CopyACharacter
    UNTIL Character = ')';
    CopyACharacter;  LastSymbol := Comment;  ReadSymbol
  END
END (*DoComment*);


PROCEDURE CheckFor (SecondChar: char; TwoCharSymbol: Symbols;
  ReadAllowed: Boolean);
BEGIN
  IF ReadAllowed
    THEN BEGIN
      Length := 1;  Symbol[1] := Character;
      SymbolName := NameOf [Character];  ReadACharacter
    END;
  IF Character = SecondChar
    THEN BEGIN
      Symbol [2] := Character;  Length := 2;
      SymbolName := TwoCharSymbol;  ReadACharacter;
      IF (NOT PackerIsOff) AND (SymbolName = Comment) THEN Length := 0
    END
END (*CheckFor*);


